home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Extensions / posix.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-24  |  11.7 KB  |  419 lines
  1. /*
  2.  *
  3.  * p o s i x . c            -- Provide some POSIX.1 functions 
  4.  *
  5.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6.  * 
  7.  *
  8.  * Permission to use, copy, and/or distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that both the above copyright notice and this permission notice appear in
  11.  * all copies and derived works.  Fees for distribution or use of this
  12.  * software or derived works may only be charged with express written
  13.  * permission of the copyright holder.  
  14.  * This software is provided ``as is'' without express or implied warranty.
  15.  *
  16.  * This software is a derivative work of other copyrighted softwares; the
  17.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  18.  *
  19.  *
  20.  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  21.  *    Creation date: 14-Mar-1995 20:14
  22.  * Last file update: 19-Jul-1996 14:34
  23.  */
  24.  
  25. #include <stk.h>
  26. #include <sys/types.h>
  27. #include <sys/utsname.h>
  28.  
  29. #define DefineConst(c) {VCELL(STk_intern(#c)) = STk_makeinteger(c);}
  30.  
  31. /******************************************************************************
  32.  * 
  33.  * Error management
  34.  *
  35.  ******************************************************************************/
  36. extern int errno;
  37.  
  38. static SCM get_errno(char *s)
  39. {
  40.   return STk_makeinteger((long) errno);
  41. }
  42.  
  43. static void set_errno(char *s, SCM value)
  44. {
  45.   long n = STk_integer_value_no_overflow(value);
  46.  
  47.   if (n == LONG_MIN) Err("setting *errno*: bad integer", value);
  48.   errno = n;
  49. }
  50.  
  51. static PRIMITIVE posix_perror(SCM str)
  52. {
  53.   if (NSTRINGP(str)) Err("posix-perror: bad string", str);
  54.   perror(CHARS(str));
  55.   return UNDEFINED;
  56. }
  57.  
  58. /******************************************************************************
  59.  *
  60.  * File and Directory functions
  61.  *
  62.  ******************************************************************************/
  63. #include <sys/stat.h>
  64.  
  65. static Cpointer_stat;
  66.  
  67. static PRIMITIVE posix_stat(SCM filename)
  68. {
  69.   struct stat *p;
  70.  
  71.   if (NSTRINGP(filename)) Err("posix-stat: bad string", filename);
  72.   
  73.   p = (struct stat *) must_malloc(sizeof(struct stat));
  74.   if (stat(CHARS(filename), p) == -1) return Ntruth;
  75.   
  76.   return STk_make_Cpointer(Cpointer_stat, (void *) p, FALSE);
  77. }
  78.  
  79. static PRIMITIVE posix_stat2vector(SCM descr)
  80. {
  81.   SCM z;
  82.   struct stat *info;
  83.  
  84.   if (NCPOINTERP(descr) || EXTID(descr) != Cpointer_stat) 
  85.     Err("posix-stat->vector: bad structure ", descr);
  86.     
  87.   info = (struct stat *) EXTDATA(descr);
  88.  
  89.   z = STk_makevect(10, NULL);
  90.   VECT(z)[0] = STk_makeinteger(info->st_dev);
  91.   VECT(z)[1] = STk_makeinteger(info->st_ino);
  92.   VECT(z)[2] = STk_makeinteger(info->st_mode);
  93.   VECT(z)[3] = STk_makeinteger(info->st_nlink);
  94.   VECT(z)[4] = STk_makeinteger(info->st_uid);
  95.   VECT(z)[5] = STk_makeinteger(info->st_gid);
  96.   VECT(z)[6] = STk_makeinteger(info->st_size);
  97.   VECT(z)[7] = STk_makeinteger(info->st_atime);
  98.   VECT(z)[8] = STk_makeinteger(info->st_mtime);
  99.   VECT(z)[9] = STk_makeinteger(info->st_ctime);
  100.  
  101.   return z;
  102. }
  103.  
  104. static PRIMITIVE posix_access(SCM filename, SCM mode)
  105. {
  106.   long m;
  107.  
  108.   if (NSTRINGP(filename)) Err("posix-access: bad string", filename);
  109.   if ((m=STk_integer_value_no_overflow(mode)) == LONG_MIN)
  110.     Err("posix-access: bad integer", mode);
  111.   return (access(CHARS(filename), (int) m) == 0) ? Truth: Ntruth;
  112. }
  113.  
  114. static PRIMITIVE posix_pipe(void)
  115. {
  116.   int fd[2];
  117.   FILE *f0, *f1;
  118.  
  119.   if (pipe(fd) == -1) return Ntruth;
  120.   
  121.   if ((f0 = fdopen(fd[0], "r")) == NULL || (f1 = fdopen(fd[1], "w")) == NULL) {
  122.     fclose(f0);   fclose(f1);
  123.     close(fd[0]); close(fd[1]);
  124.     return Ntruth;
  125.   }
  126.  
  127.   return Cons(STk_Cfile2port("pipe (input)",  f0, tc_iport, 0),
  128.           STk_Cfile2port("pipe (output)", f1, tc_oport, 0));
  129. }
  130.  
  131.  
  132.  
  133. /******************************************************************************
  134.  *
  135.  * Time functions 
  136.  *
  137.  ******************************************************************************/
  138. #include <time.h>
  139.  
  140. #ifdef SUNOS4
  141. #define mktime(c) timegm(c)
  142. #endif
  143.  
  144. static Cpointer_tm;
  145.  
  146. static void display_Cpointer_tm(SCM obj, SCM port, int mode)
  147. {
  148.   struct tm *p = (struct tm *) EXTDATA(obj);
  149.  
  150.   sprintf(STk_tkbuffer, "#<C-struct tm %02d/%02d/%02d %02d:%02d:%02d>", 
  151.               p->tm_mon,  p->tm_mday, p->tm_year,
  152.               p->tm_hour, p->tm_min,  p->tm_sec);
  153.   Puts(STk_tkbuffer, PORT_FILE(port));
  154. }
  155.  
  156. static PRIMITIVE posix_time(void)
  157. {
  158.   return STk_makeinteger((long) time(NULL));
  159. }
  160.  
  161. static PRIMITIVE posix_ctime(SCM seconds)
  162. {
  163.   long sec;
  164.  
  165.   sec = (seconds == UNBOUND) ? time(NULL)
  166.                  : STk_integer_value_no_overflow(seconds);
  167.   if (sec == LONG_MIN) Err("posix-ctime: bad time value", seconds);
  168.   
  169.   return STk_makestring(ctime((time_t *) &sec));
  170. }
  171.  
  172.  
  173. static PRIMITIVE posix_localtime(SCM timer)
  174. {
  175.   long t = STk_integer_value_no_overflow(timer);
  176.  
  177.   if (t == LONG_MIN) Err("posix-localtime: bad time value", timer);
  178.  
  179.   return STk_make_Cpointer(Cpointer_tm, (void *) localtime((time_t *) &t), TRUE);
  180. }
  181.  
  182. static PRIMITIVE posix_gmtime(SCM timer)
  183. {
  184.   long t = STk_integer_value_no_overflow(timer);
  185.  
  186.   if (t == LONG_MIN) Err("posix-gmtime: bad time value", timer);
  187.  
  188.   return STk_make_Cpointer(Cpointer_tm, (void *) gmtime((time_t *) &t), TRUE);
  189. }
  190.  
  191. static PRIMITIVE posix_mktime(SCM t)
  192. {
  193.   time_t sec;
  194.   if (NCPOINTERP(t) || EXTID(t) != Cpointer_tm) 
  195.     Err("posix-mktime: bad time structure", t);
  196.   
  197.   sec = (time_t) mktime(EXTDATA(t));
  198.   return STk_makeinteger((double) sec);
  199. }
  200.  
  201. static PRIMITIVE posix_tm2vector(SCM t)
  202. {
  203.   SCM z;
  204.   struct tm *p;
  205.   
  206.   if (NCPOINTERP(t) || EXTID(t) != Cpointer_tm) 
  207.     Err("posix-tm->vector: bad time structure", t);
  208.   
  209.   z = STk_makevect(9, NIL);
  210.   p = (struct tm *) EXTDATA(t);
  211.  
  212.   VECT(z)[0] = STk_makeinteger(p->tm_sec);
  213.   VECT(z)[1] = STk_makeinteger(p->tm_min);
  214.   VECT(z)[2] = STk_makeinteger(p->tm_hour); 
  215.   VECT(z)[3] = STk_makeinteger(p->tm_mday);
  216.   VECT(z)[4] = STk_makeinteger(p->tm_mon);
  217.   VECT(z)[5] = STk_makeinteger(p->tm_year);
  218.   VECT(z)[6] = STk_makeinteger(p->tm_wday);
  219.   VECT(z)[7] = STk_makeinteger(p->tm_yday);
  220.   VECT(z)[8] = (p->tm_isdst) ? Truth: Ntruth;
  221.  
  222.   return z;
  223. }
  224.  
  225. static PRIMITIVE vector2posix_tm(SCM v)
  226. {
  227.   struct tm *p;
  228.  
  229.   if (NVECTORP(v) || VECTSIZE(v) != 9)
  230.     Err("vector->posix-tm: bad vector", v);
  231.  
  232.   p = (struct tm *) must_malloc(sizeof(struct tm));
  233.   p->tm_sec   = STk_integer_value_no_overflow(VECT(v)[0]);
  234.   p->tm_min   = STk_integer_value_no_overflow(VECT(v)[1]);
  235.   p->tm_hour  = STk_integer_value_no_overflow(VECT(v)[2]);
  236.   p->tm_mday  = STk_integer_value_no_overflow(VECT(v)[3]);
  237.   p->tm_mon   = STk_integer_value_no_overflow(VECT(v)[4]);
  238.   p->tm_year  = STk_integer_value_no_overflow(VECT(v)[5]);
  239.   p->tm_wday  = STk_integer_value_no_overflow(VECT(v)[6]);
  240.   p->tm_yday  = STk_integer_value_no_overflow(VECT(v)[7]);
  241.   p->tm_isdst = (VECT(v)[8] == Truth);
  242.   
  243.   return STk_make_Cpointer(Cpointer_tm, p, FALSE);
  244. }
  245.  
  246. static PRIMITIVE posix_strftime(SCM format, SCM t)
  247. {
  248.   char buffer[1024];
  249.   struct tm *p;
  250.   int len;
  251.  
  252.   if (NSTRINGP(format)) 
  253.     Err("posix-strftime: Bad string", format);
  254.     
  255.   /* If t is not provided, assume that we want current localtime */
  256.   if (t == UNBOUND) {
  257.     time_t t = time(NULL);
  258.     p = localtime(&t);
  259.   }
  260.   else {
  261.     if (NCPOINTERP(t) || EXTID(t) != Cpointer_tm) 
  262.       Err("posix-strftime: bad time structure", t);
  263.     p = EXTDATA(t);
  264.   }
  265.   
  266.   if (len=strftime(buffer, 1023, CHARS(format), p))
  267.     return STk_makestring(buffer);
  268.   else
  269.     Err("posix-strftime: buffer too short", NIL);
  270. }
  271.  
  272. /******************************************************************************
  273.  *
  274.  * Processes stuff
  275.  *
  276.  ******************************************************************************/
  277.  
  278. static PRIMITIVE posix_fork(void)
  279. {
  280.   pid_t pid = fork();
  281.  
  282. #ifdef USE_TK
  283.   /* Really silly. Try to do something better  */
  284.   if (pid == 0 && Tk_initialized) {
  285.     /* Delete all the Tk commands associated to the interpreter (except send)
  286.      * to avoid interpreter unregistering 
  287.      */
  288.     
  289.     struct Tk_command *W;
  290.     Interp *iPtr = (Interp *) STk_main_interp;
  291.     Tcl_HashEntry *hPtr;
  292.  
  293.     /* Try to find "send". Modify it's delproc to point NULL */
  294.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "send");
  295.     if (hPtr != NULL) {
  296.       W = (struct Tk_command *) Tcl_GetHashValue(hPtr);
  297.       W->delproc = NULL;
  298.     }
  299.     /* Now we can destroy the interpreter  (send will not be destroyed) */
  300.     Tcl_DeleteInterp(STk_main_interp);
  301.     
  302.     /* Report-error points to a graphical procedure. Undefine it 
  303.      * to display error messages on stderr in the child process
  304.      */
  305.     STk_set_symbol_value("report-error", UNBOUND);
  306.  
  307.     /* Redefine exit to the standard STk exit function */
  308.     STk_add_new_primitive("exit", tc_subr_0_or_1, STk_quit_interpreter);
  309.   }
  310. #endif
  311.   return (pid == -1) ? Ntruth: STk_makeinteger((long) pid);
  312. }
  313.  
  314. static PRIMITIVE posix_wait(void)
  315. {
  316.   pid_t pid;
  317.   int status;
  318.   
  319.   pid = wait(&status);
  320.   if (pid == -1)
  321.     return Ntruth;
  322.   else
  323.     return Cons(STk_makeinteger((long) pid), 
  324.         STk_makeinteger((long) status));
  325. }
  326.  
  327. /******************************************************************************
  328.  *
  329.  * System infos
  330.  *     gethostname and getdomainname:  POSIX.1  does  not define these
  331.  *     functions, but ISO/IEC 9945-1:1990 mentions them in B.4.4.1. 
  332.  *            -- Linux documentation
  333.  *
  334.  ******************************************************************************/
  335.  
  336. static PRIMITIVE posix_uname(void)
  337. {
  338.   struct utsname buff;
  339.   SCM v;
  340.  
  341.   if (uname(&buff) == -1)
  342.     Err("posix-uname: cannot stat", NIL);
  343.   
  344.   v = STk_makevect(5, NIL);
  345.   VECT(v)[0] = STk_makestring(buff.sysname);
  346.   VECT(v)[1] = STk_makestring(buff.nodename);
  347.   VECT(v)[2] = STk_makestring(buff.release);
  348.   VECT(v)[3] = STk_makestring(buff.version);
  349.   VECT(v)[4] = STk_makestring(buff.machine);
  350.  
  351.   return v;
  352. }
  353.  
  354. static PRIMITIVE posix_host_name(void)
  355. {
  356.   char name[100];
  357.   
  358.   if (gethostname(name, 100) != 0)
  359.     Err("posix-host-name: cannot determine name", NIL);
  360.  
  361.   return STk_makestring(name);
  362. }
  363.  
  364. static PRIMITIVE posix_domain_name(void)
  365. {
  366.   char name[100];
  367.   
  368.   if (getdomainname(name, 100) != 0)
  369.     Err("posix-domain-name: cannot determine domain", NIL);
  370.   
  371.   return STk_makestring(name);
  372. }
  373.  
  374.  
  375. /******************************************************************************
  376.  *
  377.  * Initialization code
  378.  *
  379.  ******************************************************************************/
  380.  
  381. PRIMITIVE STk_init_posix(void)
  382. {
  383.   /* Error management */
  384.   STk_define_C_variable("*errno*", get_errno, set_errno);
  385.   STk_add_new_primitive("posix-perror",          tc_subr_1,    posix_perror);
  386.  
  387.   /* File and directories */
  388.   Cpointer_stat = STk_new_Cpointer_id(NULL);
  389.   STk_add_new_primitive("posix-stat",          tc_subr_1,    posix_stat);
  390.   STk_add_new_primitive("posix-stat->vector", tc_subr_1,    posix_stat2vector);
  391.   STk_add_new_primitive("posix-access?",      tc_subr_2,    posix_access);
  392.   STk_add_new_primitive("posix-pipe",       tc_subr_0,         posix_pipe);
  393.  
  394.   DefineConst(F_OK);      DefineConst(R_OK);      DefineConst(W_OK);
  395.   DefineConst(X_OK);
  396.  
  397.   /* Time */
  398.   Cpointer_tm = STk_new_Cpointer_id(display_Cpointer_tm);
  399.   STk_add_new_primitive("posix-time",       tc_subr_0,      posix_time);
  400.   STk_add_new_primitive("posix-ctime",      tc_subr_0_or_1, posix_ctime);  
  401.   STk_add_new_primitive("posix-localtime",  tc_subr_1,      posix_localtime);
  402.   STk_add_new_primitive("posix-gmtime",     tc_subr_1,      posix_gmtime);
  403.   STk_add_new_primitive("posix-mktime",     tc_subr_1,      posix_mktime);
  404.   STk_add_new_primitive("posix-tm->vector", tc_subr_1,      posix_tm2vector);
  405.   STk_add_new_primitive("vector->posix-tm", tc_subr_1,      vector2posix_tm);
  406.   STk_add_new_primitive("posix-strftime",   tc_subr_1_or_2, posix_strftime);
  407.  
  408.   /* Processes */
  409.   STk_add_new_primitive("posix-fork",       tc_subr_0,         posix_fork);
  410.   STk_add_new_primitive("posix-wait",       tc_subr_0,         posix_wait);
  411.   
  412.   /* System information */
  413.   STk_add_new_primitive("posix-uname",      tc_subr_0,         posix_uname);
  414.   STk_add_new_primitive("posix-host-name",  tc_subr_0,         posix_host_name);
  415.   STk_add_new_primitive("posix-domain-name",tc_subr_0,         posix_domain_name);
  416.   
  417.   return UNDEFINED;
  418. }
  419.